home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-19
/
surfsrc3.zip
/
IFF.INC
< prev
next >
Wrap
Text File
|
1991-09-25
|
10KB
|
381 lines
{ IFF.INC - IFF (Amiga Interchange File Format) support for SURFMODL }
{ Local constants, types and variables for IFF saving: }
const
Bmapsize: word = 0;
Nplanes: integer = 5;
type
Bytearray = array[0..0] of byte;
Byteptr = ^Bytearray;
formchunk = record
fc_type: array[0..3] of byte;
fc_length: longint;
fc_subtype: array[0..3] of byte;
end;
iffchunk = record
iff_type: array[0..3] of byte;
iff_length: longint;
end;
bitmapheader = record
w: word;
h: word;
x: word;
y: word;
nplanes: byte;
masking: byte;
compression: byte;
pad1: byte;
transparentcolor: word;
xaspect: byte;
yaspect: byte;
pagewidth: integer;
pageheight: integer;
end;
{ Global variables }
var IFFbmap: Byteptr; { pointer to screen bitmap }
Shiftvals: array[0..7] of byte; { values to do bit shifts }
IFFxmax: word; { max screen coord }
IFFymax: word; { max screen coord }
IFFcolors: integer; { # screen colors }
{ MEMSET: Set every byte in specified memory to a specified value. }
procedure MEMSET (dat: pointer; val, len: word);
var i: word;
p: Byteptr;
begin
p := dat;
for i := 0 to len-1 do
p^[i] := val;
end; { procedure MEMSET }
procedure INITIFF;
var i: integer;
Shiftval: integer;
begin
{ Free up the old bitmap, if there is one }
if (Bmapsize > 0) then
freemem (IFFbmap, Bmapsize);
{ Allocate the bitmap. Note we use one byte per pixel, so the color
resolution is the same as VGA (8-bit).
}
IFFxmax := getmaxx;
IFFymax := getmaxy;
IFFcolors := getmaxcolor;
Bmapsize := (IFFxmax+1) * (IFFymax+1);
getmem (IFFbmap, Bmapsize);
if (IFFbmap = NIL) then begin
writeln('Out of memory allocating bitmap');
Bmapsize := 0;
halt;
end;
{ Initialize to zero }
memset (IFFbmap, 0, Bmapsize);
{ Finally we initialize the shift values. This is necessary because
Pascal doesn't have a shift operator (that I know of). But hey what
do I know, I'm just a C programmer at heart.
}
Shiftval := 1;
for i := 0 to 7 do begin
Shiftvals[i] := Shiftval;
Shiftval := Shiftval * 2;
end;
end; { procedure INITIFF }
procedure EXITIFF;
begin
{ Free up the old bitmap, if there is one }
if (Bmapsize > 0) then
freemem (IFFbmap, Bmapsize);
Bmapsize := 0;
end; { procedure EXITIFF }
procedure IFFPLOT (X, Y, Color: integer);
var Offs: word; { Offset into bitmap }
{$ifdef NEVER}
Value: integer;
{$endif}
begin
if (X < 0) or (X > IFFxmax) or (Y < 0) or (Y > IFFymax) or
(Color < 0) or (Color > 255) then begin
writeln('IFFPLOT: Illegal parameters X=', X, ' Y=', Y, ' Color=', Color);
halt;
end;
{ Find the offset into the bitmap for this pixel }
Offs := Y * (IFFxmax+1) + X;
IFFbmap^[Offs] := Color;
{$ifdef NEVER}
writeln('X=', X, ' Y=', Y, ' Color=', Color);
Value := ord (IFFbmap^[Offs]);
write(' IFFbmap[', Offs, ']: Val=', Value);
showptr(@IFFbmap^[Offs]);
{$endif}
end; { procedure IFFPLOT }
procedure SWAP_BYTES (dat: pointer; len: word);
var tmp: byte;
i1, i2: word;
p: Byteptr;
begin
p := dat;
i1 := 0;
i2 := len - 1;
while (i1 < i2) do begin
tmp := p^[i2];
p^[i2] := p^[i1];
p^[i1] := tmp;
i1 := i1 + 1;
i2 := i2 - 1;
end;
end; { procedure SWAP_BYTES }
{ GET1ROW: Transform one bitplane of one row of pixels from our internal
(VGA-type) format into IFF format.
}
procedure GET1ROW (y, plane: integer; var row: RowArray; var nbytes: integer);
var Offs: word; { offset into bitmap }
bit: integer; { current bit# in byte }
Col: byte; { color of current pixel }
Value: byte; { color value for this bitplane }
n: integer; { current byte number in this line }
begin
if (Plane < 0) or (Plane >= Nplanes) or (y < 0) or (y > IFFymax) then begin
writeln ('GET1ROW - Invalid input Plane=', plane, ' y=', y);
halt;
end;
{ Calculate offset into bitplane }
Offs := y * (IFFxmax + 1);
nbytes := (IFFxmax + 1) div 8;
{ Do for each group of 8 pixels across the screen. Note we handle 8
pixels at a time to save calculation, since that is how we need it
represented for IFF.
}
for n := 0 to nbytes-1 do begin
row[n] := 0;
{ Do for each pixel in the group of 8. Note that we need to read
each bit in reverse order.
}
for Bit := 7 downto 0 do begin
Col := ord (IFFbmap^[Offs]);
Offs := Offs + 1;
if (Col >= IFFcolors) then begin
writeln ('ERROR in GET1ROW: Col=', Col);
halt;
end;
{ Mask off the bitplane that was requested, and shift it down to bit 0: }
Value := (Col and Shiftvals[Plane]) div Shiftvals[Plane];
{Finally, shift the value into the appropriate bit pos for IFF: }
row[n] := row[n] or (Value * Shiftvals[Bit]);
end; { for i }
end; { for n }
end; { procedure GET1ROW }
procedure WRITE_BODY (var out: file; var tot_len: longint);
var y: integer;
plane: integer;
nbytes: integer;
row: RowArray;
begin
{ For each row }
for y := 0 to IFFymax do begin
{ For each bitplane }
for plane := 0 to Nplanes-1 do begin
get1row (y, plane, row, nbytes);
blockwrite (out, row, nbytes);
tot_len := tot_len + nbytes;
end;
end;
end; { procedure WRITE_BODY }
procedure SAVEIFF (Filename: string; var Pal: SurfPalette);
var tmp: longint;
out: file;
form: formchunk;
iff: iffchunk;
hdr: bitmapheader;
r, g, b: integer;
{$ifdef NEVER}
curr: integer;
ch: char;
{$endif}
tot_len: longint;
name: string[4];
begin
{$ifdef NEVER}
window(1,1,80,25);
clrscr;
{$endif}
if (Bmapsize = 0) then begin
writeln ('SAVEIFF ERROR: Never initialized!');
halt;
end;
{$I-}
assign (out, Filename);
rewrite (out, 1);
{$I+}
if (ioresult <> 0) then begin
writeln ('Error: Can''t create ', Filename);
halt;
end;
{ FORM: ILBM (Interleaved BitMap) }
name := 'FORM';
move (name[1], form.fc_type, 4);
tmp := ((IFFxmax+1) div 8) * Nplanes;
form.fc_length := 12 + 28 + 8 + (3*IFFcolors) + 8 + tmp * (IFFymax+1);
{ KVC 09/25/91 For some reason IFFCHECK expects this number to be 8
smaller than I calculate. Don't know why, but here's a correction
to force it:
}
form.fc_length := form.fc_length - 8;
{$ifdef NEVER}
writeln('Expected file size: ', form.fc_length);
{$endif}
name := 'ILBM';
move (name[1], form.fc_subtype, 4);
swap_bytes (@form.fc_length, sizeof(longint));
blockwrite (out, form, sizeof(form));
tot_len := sizeof(form);
{$ifdef NEVER}
writeln('After ILBM: ', tot_len);
{$endif}
{ BMHD (Bitmap Header) }
name := 'BMHD';
move (name[1], iff.iff_type, 4);
iff.iff_length := sizeof(hdr);
swap_bytes (@iff.iff_length, 4);
blockwrite (out, iff, sizeof(iff));
tot_len := tot_len + sizeof(iff);
{$ifdef NEVER}
writeln('After BMHD: ', tot_len, ' (should be 20)');
{$endif}
hdr.w := IFFxmax + 1;
hdr.h := IFFymax + 1;
hdr.x := 0;
hdr.y := 0;
hdr.nplanes := Nplanes;
hdr.masking := 0;
hdr.compression := 0;
hdr.pad1 := 0;
hdr.transparentcolor := 0;
hdr.xaspect := 10;
hdr.yaspect := 11;
hdr.pagewidth := IFFxmax + 1;
hdr.pageheight := IFFymax + 1;
hdr.w := swap (hdr.w);
hdr.h := swap (hdr.h);
hdr.x := swap (hdr.x);
hdr.y := swap (hdr.y);
hdr.transparentcolor := swap (hdr.transparentcolor);
hdr.pagewidth := swap (hdr.pagewidth);
hdr.pageheight := swap (hdr.pageheight);
blockwrite (out, hdr, sizeof(hdr));
tot_len := tot_len + sizeof(hdr);
{$ifdef NEVER}
writeln('After hdr: ', tot_len, ' (should be 40)');
{$endif}
{ Color Map }
name := 'CMAP';
move (name[1], iff.iff_type, 4);
iff.iff_length := 3 * IFFcolors;
swap_bytes (@iff.iff_length, 4);
blockwrite (out, iff, sizeof(iff));
tot_len := tot_len + sizeof(iff);
{$ifdef NEVER}
writeln('After CMAP: ', tot_len, ' (should be 48)');
{$endif}
{$ifdef NEVER}
{ Set up a greyscale color map }
for curr := 0 to 15 do begin
Pal[curr].Rvalue := curr * 16;
Pal[curr].Gvalue := curr * 16;
Pal[curr].Bvalue := curr * 16;
writeln('Color ', curr, ': [', Pal[curr].Rvalue, ',',
Pal[curr].Gvalue, ',', Pal[curr].Bvalue, ']');
end;
if (IFFcolors > 16) then begin
{ Set the rest of the colors to white }
for curr := 16 to MAXCOLORS do begin
Pal[curr].Rvalue := 15;
Pal[curr].Gvalue := 15;
Pal[curr].Bvalue := 15;
end;
end;
{$endif}
{$ifdef NEVER}
for curr := 1 to 16 do
writeln('Color ', curr, ': [', Pal[curr].Rvalue, ',',
Pal[curr].Gvalue, ',', Pal[curr].Bvalue, ']');
write('Press any key to continue...');
ch := readkey;
writeln;
for curr := 17 to IFFcolors do
writeln('Color ', curr, ': [', Pal[curr].Rvalue, ',',
Pal[curr].Gvalue, ',', Pal[curr].Bvalue, ']');
write('Press any key to continue...');
ch := readkey;
writeln;
{$endif}
blockwrite (out, Pal, IFFcolors * sizeof(ColorValue));
tot_len := tot_len + IFFcolors * sizeof(ColorValue);
{$ifdef NEVER}
writeln('After cmap: ', tot_len, ' (sz=', IFFcolors * sizeof(ColorValue),
') (tot should be 144)');
{$endif}
{ Finally save the body of the picture: }
name := 'BODY';
move (name[1], iff.iff_type, 4);
iff.iff_length := (IFFxmax + 1) div 8 * (IFFymax + 1) * Nplanes;
swap_bytes (@iff.iff_length, 4);
blockwrite (out, iff, sizeof(iff));
tot_len := tot_len + sizeof(iff);
{$ifdef NEVER}
writeln('After BODY: ', tot_len, ' (should be 152)');
{$endif}
write_body (out, tot_len);
{$ifdef NEVER}
writeln('After body: ', tot_len, ' (should be 40152)');
{$endif}
{ If we start using compression, we will have to seek back to the point
where the body length was written, and update it. We will also have
to seek back to where the initial ILBM header was written, and update
its length too.
}
close (out);
{$ifdef NEVER}
writeln('Actual file size: ', tot_len);
{$endif}
end; { procedure SAVEIFF }